Chip 1996 September/CHIP 1996 szeptember (CD07).zip/CHIP_CD07.ISO/sac/pack/vblha1.lzh/FRMLHA.FRM

Text File | 1995-05-09 | 10KB | 467 lines

VERSION 2.00
Begin Form frmlha
   AutoRedraw      =   -1  'True
   Caption         =   "LHA file contents"
   Height          =   4440
   Left            =   825
   LinkTopic       =   "Form1"
   ScaleHeight     =   4035
   ScaleWidth      =   3315
   Top             =   1185
   Width           =   3435
   Begin CommandButton cmdVersion
      Caption         =   "LHA &Version"
      Height          =   495
      Left            =   2040
      TabIndex        =   7
      Top             =   1440
      Width           =   1095
   End
   Begin PictureBox picFile2
      Height          =   615
      Left            =   3720
      Picture         =   FRMLHA.FRX:0000
      ScaleHeight     =   585
      ScaleWidth      =   465
      TabIndex        =   6
      Top             =   960
      Width           =   495
   End
   Begin PictureBox PicFile1
      Height          =   615
      Left            =   3720
      Picture         =   FRMLHA.FRX:0302
      ScaleHeight     =   585
      ScaleWidth      =   465
      TabIndex        =   5
      Top             =   240
      Width           =   495
   End
   Begin CommandButton cmdDelete
      Caption         =   "&Delete"
      Height          =   495
      Left            =   2040
      TabIndex        =   4
      Top             =   3240
      Width           =   1095
   End
   Begin CommandButton cmdExtract
      Caption         =   "&Extract"
      Height          =   495
      Left            =   2040
      TabIndex        =   3
      Top             =   2040
      Width           =   1095
   End
   Begin CommandButton cmdCancel
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   495
      Left            =   2040
      TabIndex        =   2
      Top             =   840
      Width           =   1095
   End
   Begin CommandButton cmdOK
      Caption         =   "&OK"
      Default         =   -1  'True
      Height          =   495
      Left            =   2040
      TabIndex        =   1
      Top             =   240
      Width           =   1095
   End
   Begin ListBox lstLHAcontents
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Terminal"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   3540
      Left            =   240
      MultiSelect     =   2  'ègÆú
      TabIndex        =   0
      Top             =   240
      Width           =   1575
   End
End
Sub cmdCancel_Click ()

' set the frmlha.tag to null
  frmLHA.Tag = ""

' hide the frmlha
frmLHA.Hide

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdDelete_Click ()

Dim retcode As Integer
Dim curpath As String
Dim cnt
Dim numitem

'Reset buffer size
buffer = Space(szbuff)

'Save current path
curpath = CurDir

ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path

numitem = lstLHAcontents.ListCount
cnt = 0
Do While cnt < numitem
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "d " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)

   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)

   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
   lstLHAcontents.RemoveItem cnt
   numitem = numitem - 1
 Else
   cnt = cnt + 1
 End If
Loop

'Return to original drive
ChDrive Mid$(curpath, 1, 2)

'Return to original path
ChDir curpath

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdDelete_DragDrop (Source As Control, X As Single, Y As Single)

Dim retcode As Integer
Dim curpath As String
Dim cnt
Dim numitem

'Save current path
curpath = CurDir

ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path

numitem = lstLHAcontents.ListCount
cnt = 0
Do While cnt < numitem
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "d " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)

   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)

   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
   lstLHAcontents.RemoveItem cnt
   numitem = numitem - 1
 Else
   cnt = cnt + 1
 End If
Loop

'Return to original drive
ChDrive Mid$(curpath, 1, 2)

'Return to original path
ChDir curpath

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdDelete_DragOver (Source As Control, X As Single, Y As Single, State As Integer)

Select Case State
  Case 0
    'change icon to release
     lstLHAcontents.DragIcon = picFile2
  Case 1
    'change icon to release
     lstLHAcontents.DragIcon = picFile1
End Select

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdExtract_Click ()

Dim retcode As Integer
Dim curpath As String
Dim cnt

'Reset buffer size
buffer = Space(szbuff)

'Save current path
curpath = CurDir

ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path

For cnt = 0 To lstLHAcontents.ListCount - 1
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "e " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)

   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)

   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
 End If
Next cnt

'Return to original drive
ChDrive Mid$(curpath, 1, 2)

'Return to original path
ChDir curpath

'refresh getfile file box
frmgetfile.filFiles.Refresh

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdExtract_DragDrop (Source As Control, X As Single, Y As Single)

Dim retcode As Integer
Dim curpath As String
Dim cnt

'Save current path
curpath = CurDir

ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path

For cnt = 0 To lstLHAcontents.ListCount - 1
 If lstLHAcontents.Selected(cnt) Then
   'Create LHA command
   cmd = "e " & frmgetfile.Tag & " " & lstLHAcontents.List(cnt)

   'Perform LHA operation
    retcode = lha(cmd, buffer, szbuff)

   'Check for error
   If retcode <> 0 Then
     MsgBox ("Error: " & retcode)
     Exit Sub
   End If
 End If
Next cnt

'Return to original drive
ChDrive Mid$(curpath, 1, 2)

'Return to original path
ChDir curpath

'refresh getfile file box
frmgetfile.filFiles.Refresh

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdExtract_DragOver (Source As Control, X As Single, Y As Single, State As Integer)

Select Case State
  Case 0
    'change icon to release
     lstLHAcontents.DragIcon = picFile2
  Case 1
    'change icon to release
     lstLHAcontents.DragIcon = picFile1
End Select

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub cmdOK_Click ()

Dim retcode As Integer
Dim curpath As String

'Check if file selected
If lstLHAcontents.Text = "" Then
  frmLHA.Tag = ""
  frmLHA.Hide
End If

'Save current path
curpath = CurDir

'Change to file's drive and path
ChDrive Mid$(frmgetfile.Tag, 1, 2)
ChDir frmgetfile.filFiles.Path

'Check if file already exists
On Error GoTo ExtFile
 retcode = GetAttr(lstLHAcontents.Text)
 retcode = MsgBox("Overwrite existing file?", 308, "File already exists!")
If retcode = 6 Then
   Kill lstLHAcontents.Text
   GoTo ExtFile
 End If
Exit Sub

ExtFile:
'Create LHA command
cmd = "e " & frmgetfile.Tag & " " & lstLHAcontents.Text

'Perform LHA operation
retcode = lha(cmd, buffer, szbuff)

'Check for error
If retcode <> 0 Then
 MsgBox ("LHA.DLL Error: " & retcode)
 Exit Sub
End If

'Return to original drive
ChDrive Mid$(curpath, 1, 2)

'Return to original path
ChDir curpath

'refresh getfile file box
frmgetfile.filFiles.Refresh

'Assign selection to tag
frmLHA.Tag = lstLHAcontents.Text

frmLHA.Hide

Exit Sub
End Sub

Sub cmdtop_Click ()

'        If VisibleFrame Is Nothing Then
'            frmCallDlls!fraInfo(0).Visible = False
'        Else
'            VisibleFrame.Visible = False
'        End If
'        frmCallDlls!fraInfo(Index + 1).Visible = True
'        Set VisibleFrame = frmCallDlls!fraInfo(Index + 1)
'    Else
'        mnuSysInfo(Index).Checked = Not mnuSysInfo(Index).Checked
'        If mnuSysInfo(Index).Checked Then
'            SetWindowPos frmCallDlls.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW
'        Else
'            SetWindowPos frmCallDlls.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW
'        End If


End Sub

Sub cmdVersion_Click ()

Dim retcode As Integer

'Perform LHA operation
retcode = LhaGetVersion()

retcode = MsgBox("Current Version: " & retcode, 0, "LHA.DLL Information")

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub Form_Activate ()

Dim cnt As Integer
Dim retcode As Integer
Dim stptr
Dim endptr

'Reset buffer size
buffer = Space(szbuff)

'Clear list box
lstLHAcontents.Clear
frmLHA.Refresh

'Create LHA command
cmd = "l " & frmgetfile.Tag

'Perform LHA operation
retcode = lha(cmd, buffer, szbuff)

'Check for error
If retcode <> 0 Then
 MsgBox ("Error: " & retcode)
 Exit Sub
End If

'Skip past header
endptr = InStr(buffer, "-")
stptr = InStr(endptr, buffer, Chr(10))

Do While Mid$(buffer, stptr, 1) <> "-"
'Skip past chr(10)
  stptr = InStr(stptr, buffer, " ")

'Skip past spaces
  stptr = 13 - Len(LTrim$(Mid$(buffer, stptr, 13))) + stptr

'Find end of file name
  endptr = InStr(stptr, buffer, " ")

'Add filename to list
  lstLHAcontents.AddItem Trim(Mid$(buffer, stptr, endptr - stptr))

'Skip to end of row
  stptr = InStr(stptr, buffer, Chr(10)) + 1

'Check for going past end of buffer
  If stptr >= szbuff Then
    Exit Do
  End If
Loop

lstLHAcontents.Refresh

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub lstLHAcontents_DblClick ()

'Execute the cmdOK_Click() procedure and close frmlha
cmdOK_Click

End Sub

'Copyright 1995 by Hitoshi Ozawa
Sub lstLHAcontents_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)

'Change drag icon
lstLHAcontents.DragIcon = picFile1

'Enable drag
lstLHAcontents.Drag

End Sub